home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / depend / dependency-analysis.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.0 KB  |  139 lines  |  [TEXT/CCL2]
  1. y-top
  2.       (**let all-decls (make void)))))
  3.  
  4.  
  5. (define *depend-fn-table* (make-table))
  6.  
  7. (define-syntax (var-depend-fn var)
  8.   `(table-entry *depend-fn-table* ,var))
  9.  
  10. (define (analyze-dependency-top x)
  11.   (dynamic-let ((*depend-fn-table*  (make-table)))
  12.     (analyze-dependency x)))
  13.  
  14.  
  15. ;;; This is the entry point to dependency analysis for an expression or decl
  16.  
  17. (define (analyze-dependency x)
  18.   (call-walker depend x))
  19.  
  20. (define (analyze-dependency/list l)
  21.   (dolist (x l)
  22.     (analyze-dependency x)))
  23.  
  24. ;;; This makes default walkers for dependency analysis.  Expressions are
  25. ;;; walked into; declaration lists must be sorted.
  26.  
  27. (define-local-syntax (make-depend-code slot type)
  28.   (let ((stype  (sd-type slot))
  29.         (sname  (sd-name slot))
  30.     (depend-exp-types '(exp alt qual single-fun-def guarded-rhs)))
  31.     (cond ((and (symbol? stype)
  32.         (memq stype depend-exp-types))
  33.        `(analyze-dependency (struct-slot ',type ',sname object)))
  34.           ((and (pair? stype)
  35.                 (eq? (car stype) 'list)
  36.                 (symbol? (cadr stype))
  37.                 (memq (cadr stype) depend-exp-types)
  38.        `(analyze-dependency/list
  39.         (struct-slot ',type ',sname object))))
  40.           ((equal? stype '(list decl))
  41.        `(setf (struct-slot ',type ',sname object)
  42.           (restructure-decl-list (struct-slot ',type ',sname object))))
  43.           (else
  44. ;           (format '#t "Depend: skipping slot ~A in ~A~%"
  45. ;                  (sd-name slot)
  46. ;                  type)
  47.            '#f))))
  48.  
  49. (define-modify-walker-methods depend
  50.   (lambda let if case alt exp-sign app con-ref
  51.    integer-const float-const char-const string-const
  52.    list-exp sequence sequence-then sequence-to sequence-then-to
  53.    list-comp section-l section-r qual-generator qual-filter omitted-guard
  54.    con-number sel is-constructor cast void
  55.    single-fun-def guarded-rhs
  56.    case-block return-from and-exp
  57.    bottom
  58.    )
  59.   (object)
  60.   make-depend-code)
  61.  
  62. ;;; This sorts a list of decls.  Recursive groups are placed in
  63. ;;; special structures: recursive-decl-group
  64.  
  65. (define (restructure-decl-list decls)
  66.   (let ((stack '())
  67.     (now 0)
  68.     (sorted-decls '())
  69.     (edge-fn '()))
  70.    (letrec ((visit (lambda (k)
  71.              (let ((minval 0)
  72.                (recursive? '#f)
  73.                (old-edge-fn edge-fn))
  74.                (incf now)
  75. ;               (format '#t "Visiting ~A: id = ~A~%" (valdef-lhs k) now)
  76.                (setf (valdef-depend-val k) now)
  77.                (setf minval now)
  78.                (push k stack)
  79.                (setf edge-fn
  80.                  (lambda (tv)
  81. ;                   (format '#t "Edge ~A -> ~A~%" (valdef-lhs k)
  82. ;                                             (valdef-lhs tv))
  83.                    (let ((val (valdef-depend-val tv)))
  84.                                 (cond ((eq? tv k)
  85.                        (setf recursive? '#t))
  86.                       ((eqv? val 0)
  87.                        (setf minval (min minval
  88.                              (funcall visit tv))))
  89.                       (else
  90.                        (setf minval (min minval val))))
  91. ;                (format '#t "Min for ~A is ~A~%"
  92. ;                    (valdef-lhs k) minval)
  93.                    )))
  94.                (analyze-dependency/list (valdef-definitions k))
  95.                (setf edge-fn old-edge-fn)
  96.                (when (eqv? minval (valdef-depend-val k))
  97.              (let ((defs '()))
  98.                (do ((quit? '#f)) (quit?)
  99.                  (push (car stack) defs)
  100.                  (setf (valdef-depend-val (car stack)) 100000)
  101.                  (setf quit? (eq? (car stack) k))
  102.                  (setf stack (cdr stack)))
  103. ;               (format '#t "Popping stack: ~A~%"
  104. ;                   (map (lambda (x) (valdef-lhs x)) defs))
  105.                (if (and (null? (cdr defs))
  106.                     (not recursive?))
  107.                    (push k sorted-decls)
  108.                    (push (make recursive-decl-group (decls defs))
  109.                      sorted-decls))))
  110.                minval))))
  111.     ;; for now assume all decl lists have only valdefs
  112.     (dolist (d decls)
  113.       (let ((decl d))  ; to force new binding for each closure
  114.     (setf (valdef-depend-val decl) 0)
  115.     (dolist (var (collect-pattern-vars (valdef-lhs decl)))
  116.       (setf (var-depend-fn (var-ref-var var))
  117.         (lambda () (funcall edge-fn decl))))))
  118.     (dolist (decl decls)
  119.       (when (eqv? (valdef-depend-val decl) 0)
  120.     (funcall visit decl)))
  121.     (dolist (decl decls)
  122.       (dolist (var (collect-pattern-vars (valdef-lhs decl)))
  123.     (setf (var-depend-fn (var-ref-var var)) '#f)))
  124.     (nreverse sorted-decls))))
  125.  
  126. ;;; This is the only non-default walker needed.  When a reference to a
  127. ;;; variable is encountered, the sort algorithm above is notified.
  128.  
  129. (define-walker-method depend var-ref (object)
  130.   (let ((fn (var-depend-fn (var-ref-var object))))
  131.     (when (not (eq? fn '#f))
  132.        (funcall fn))))
  133.  
  134. (define-walker-method depend overloaded-var-ref (object)
  135.   (let ((fn (var-depend-fn (overloaded-var-ref-var object))))
  136.     (when (not (eq? fn '#f))
  137.        (funcall fn))))
  138.  
  139.